Micom Basic 1995 October/CD [BM9510].bin/basic/vb_ken/module1.bas

BASIC Source File | 1995-08-15 | 8.2 KB | 353 lines

Option Explicit
Type Cell
    ptrCell(4) As Integer
    wall(4) As Integer
End Type

Type path
    x As Integer
    y As Integer
    direction As Integer
End Type

Global wall%(1024)
Global mazeMap(1024) As Cell
Global mazeWidth%
Global mazeHeight%
Dim mazePath(1024) As path
Dim mazePathMap(64, 64)
Dim pathLen%

Dim pathLen2%
Dim mazeSubPath(256) As path
Dim callNum%
Dim dx%(4)
Dim dy%(4)

Sub addPath (x%, y%, direction%)
    Dim nx%, ny%
    mazePath(pathLen).x = x
    mazePath(pathLen).y = y
    mazePath(pathLen).direction = direction

    mazePathMap(x, y) = -1

    mazeMap(x + mazeWidth * y).ptrCell(0) = -1
    mazeMap(x + mazeWidth * y).ptrCell(1) = -1
    mazeMap(x + mazeWidth * y).ptrCell(2) = -1
    mazeMap(x + mazeWidth * y).ptrCell(3) = -1
    nx = dx(direction) + x
    ny = dy(direction) + y
    mazeMap(x + mazeWidth * y).ptrCell(direction) = ny * mazeWidth + nx

    pathLen = pathLen + 1
End Sub

Sub addSubPath (x%, y%, direction%)
    Dim nx%, ny%

    mazeSubPath(pathLen2).x = x
    mazeSubPath(pathLen2).y = y
    mazeSubPath(pathLen2).direction = direction

    mazePathMap(x, y) = -1

    mazeMap(x + mazeWidth * y).ptrCell(0) = -1
    mazeMap(x + mazeWidth * y).ptrCell(1) = -1
    mazeMap(x + mazeWidth * y).ptrCell(2) = -1
    mazeMap(x + mazeWidth * y).ptrCell(3) = -1
    nx = dx(direction) + x
    ny = dy(direction) + y
    mazeMap(x + mazeWidth * y).ptrCell(direction) = ny * mazeWidth + nx


    pathLen2 = pathLen2 + 1
End Sub

Sub createMaze (w%, h%)
    Dim i%, j%, tmp1%, tmp2%, tmp3%, tmp4%


    mazeWidth = w
    mazeHeight = h

    Do
        callNum = 0
        initMaze
        i = createPath(w - 1, h - 1)
        If i = 1 Then
            Exit Do
        End If
    Loop

    createPath2
    createWall
    printMaze
End Sub

Function createPath% (x%, y%)
    Dim i%, ret%, nx%, ny%, flag%
    ReDim direction(4) As Integer

    callNum = callNum + 1
    If callNum > 1000 Then
        createPath = -1
        Exit Function
    End If

    If x = 0 And y = 0 Then
        createPath = 1
        Exit Function
    End If

   initDir direction()

    For i = 0 To 3
        nx = x + dx(direction(i))
        ny = y + dy(direction(i))

        If nx < mazeWidth And ny < mazeHeight And nx >= 0 And ny >= 0 Then
        If mazePathMap(nx, ny) <> -1 Then
            addPath x, y, direction(i)
            ret = createPath(nx, ny)
            If ret = 1 Then
                createPath = 1
                Exit Function
            End If
            removePath
        End If
        End If
    Next i

    createPath = -1
End Function

Sub createPath2 ()
    Dim i%, j%, x%, y%, d%, tmp%, ret%

    For i = 0 To pathLen - 1
        x = mazePath(i).x
        y = mazePath(i).y
        d = mazePath(i).direction
        wall(mazeMap(y * mazeWidth + x).wall(0)) = -1
        wall(mazeMap(y * mazeWidth + x).wall(1)) = -1
        wall(mazeMap(y * mazeWidth + x).wall(2)) = -1
        wall(mazeMap(y * mazeWidth + x).wall(3)) = -1

        tmp = Int(Rnd * 3)
        If tmp = 0 Then
            pathLen2 = 0
            ret = createSubPath(x, y)
            For j = 0 To pathLen2 - 1
                x = mazeSubPath(j).x
                y = mazeSubPath(j).y
                d = mazeSubPath(j).direction
                wall(mazeMap(y * mazeWidth + x).wall(0)) = -1
                wall(mazeMap(y * mazeWidth + x).wall(1)) = -1
                wall(mazeMap(y * mazeWidth + x).wall(2)) = -1
                wall(mazeMap(y * mazeWidth + x).wall(3)) = -1
            Next j
            For j = 0 To pathLen2 - 2
                x = mazeSubPath(j).x
                y = mazeSubPath(j).y
                d = mazeSubPath(j).direction
                wall(mazeMap(y * mazeWidth + x).wall(d)) = 1
            Next j
        End If
    Next i

End Sub

Function createSubPath% (x%, y%)
    Dim i%, ret%, nx%, ny%
    ReDim direction(4) As Integer

    If x = 0 And y = 0 Then
        createSubPath = -1
        Exit Function
    End If

   initDir direction()

    For i = 0 To 3
        nx = x + dx(direction(i))
        ny = y + dy(direction(i))


        If nx < mazeWidth And ny < mazeHeight And nx >= 0 And ny >= 0 Then
        If mazePathMap(nx, ny) <> -1 Then
            addSubPath x, y, direction(i)
            ret = createSubPath(nx, ny)
            If ret = 1 Then
                createSubPath = 1
                Exit Function
            End If
            removeSubPath
        End If
        End If
    Next i

    createSubPath = 1
End Function

Sub createWall ()
    Dim i%, x%, y%, d%, tmp%
    ReDim direction%(4)


    For i = 0 To pathLen - 1
        x = mazePath(i).x
        y = mazePath(i).y
        d = mazePath(i).direction

        wall(mazeMap(y * mazeWidth + x).wall(d)) = 0
    Next i
End Sub

Sub initDir (direction%())
    Dim tmp%

    tmp = Int(4 * Rnd)
    direction(0) = tmp

    Do
        tmp = Int(4 * Rnd)
        If tmp <> direction(0) Then
            direction(1) = tmp
            Exit Do
        End If
    Loop

    Do
        tmp = Int(4 * Rnd)
        If tmp <> direction(0) And tmp <> direction(1) Then
            direction(2) = tmp
            Exit Do
        End If
    Loop

    Do
        tmp = Int(4 * Rnd)
        If tmp <> direction(0) And tmp <> direction(1) And tmp <> direction(2) Then
            direction(3) = tmp
            Exit Do
        End If
    Loop

End Sub

Sub initMaze ()
    Dim i%, j%, w%, h%

    w = mazeWidth
    h = mazeHeight

    For i = 0 To h - 1
        For j = 0 To w - 1
            mazeMap(j + w * i).wall(3) = i * (w + 1) + j
            mazeMap(j + w * i).wall(1) = i * (w + 1) + j + 1
        Next j
    Next i

    For i = 0 To w - 1
        For j = 0 To h - 1
            mazeMap(j * w + i).wall(0) = i * (h + 1) + j + (w + 1) * h
            mazeMap(j * w + i).wall(2) = i * (h + 1) + j + 1 + (w + 1) * h
        Next j
    Next i

    For i = 0 To (w + 1) * h - 1
        wall(i) = 0
    Next i

    For i = (w + 1) * h To (h + 1) * w - 1 + (w + 1) * h
        wall(i) = 0
    Next i

    For i = 0 To h - 1
        wall(mazeMap(w * i).wall(3)) = -1
        wall(mazeMap(w - 1 + i * w).wall(1)) = -1
    Next i
    For i = 0 To w - 1
        wall(mazeMap(i).wall(0)) = -1
        wall(mazeMap(i + w * (h - 1)).wall(2)) = -1
    Next i

    pathLen = 0
    For i = 0 To h - 1
        For j = 0 To w - 1
            mazePathMap(i, j) = 0
        Next j
    Next i

    dx(0) = 0
    dx(1) = 1
    dx(2) = 0
    dx(3) = -1
    dy(0) = -1
    dy(1) = 0
    dy(2) = 1
    dy(3) = 0
End Sub

Sub printMaze ()
    Dim i%, j%, PX%, PY%, dx%, dy%, w%

    w = 59

    For i = 0 To mazeHeight - 1
        For j = 0 To mazeWidth - 1
            PX = j * w + 10
            PY = i * w + 10
            If wall(mazeMap(j + i * mazeWidth).wall(3)) = -1 Then
                form1.Line (PX, PY)-(PX, PY + w)
            End If

            If wall(mazeMap(j + i * mazeWidth).wall(1)) = -1 Then
                form1.Line (PX + w, PY)-(PX + w, PY + w)
            End If

            If wall(mazeMap(j + i * mazeWidth).wall(0)) = -1 Then
                form1.Line (PX, PY)-(PX + w, PY)
            End If

            If wall(mazeMap(j + i * mazeWidth).wall(2)) = -1 Then
                form1.Line (PX, PY + w)-(PX + w, PY + w)
            End If


        Next j
    Next i

End Sub

Sub removePath ()
    Dim x%, y%

    x = mazePath(pathLen - 1).x
    y = mazePath(pathLen - 1).y
    mazePathMap(x, y) = 0
    mazeMap(x + mazeWidth * y).ptrCell(0) = -1
    mazeMap(x + mazeWidth * y).ptrCell(1) = -1
    mazeMap(x + mazeWidth * y).ptrCell(2) = -1
    mazeMap(x + mazeWidth * y).ptrCell(3) = -1

    pathLen = pathLen - 1
End Sub

Sub removeSubPath ()
    Dim x%, y%

    x = mazeSubPath(pathLen - 1).x
    y = mazeSubPath(pathLen - 1).y
    mazePathMap(x, y) = 0

    mazeMap(x + mazeWidth * y).ptrCell(0) = -1
    mazeMap(x + mazeWidth * y).ptrCell(1) = -1
    mazeMap(x + mazeWidth * y).ptrCell(2) = -1
    mazeMap(x + mazeWidth * y).ptrCell(3) = -1

    pathLen2 = pathLen2 - 1
End Sub